home *** CD-ROM | disk | FTP | other *** search
/ CU Amiga Super CD-ROM 27 / CU Amiga Magazine's Super CD-ROM 27 (1998)(EMAP Images)(GB)[!][issue 1998-10].iso / CUCD / Programming / JForth / Extras / Floats / float.ffp < prev   
Encoding:
Text File  |  1992-04-28  |  32.7 KB  |  1,047 lines
  1. \ JFVGFP.FFP   Revised: 1/29/89    Length 12,298 bytes with max-inline=16
  2. \
  3. \ A FFP ( fast floating point ) JForth implementation of the
  4. \  Forth Vendors Group Floating Point Extension
  5. \  Dr. Dobb's Journal September 1984.
  6. \
  7. \ Copyright 1987 by
  8. \            David J. Sirag,
  9. \            17215 S. Harvest Ave.,
  10. \            Cerritos, CA 90701.
  11. \  Permission is hereby granted to distribute this code with JFORTH
  12. \  with the provision that this copyright notice and permission
  13. \  statement are included with the code.  It may be used by licensed
  14. \  users of JFORTH with the same restrictions as if it were part of
  15. \  JFORTH.
  16. \
  17. \ >>>>>>>>>>>>>>>
  18. \ Modifications by Phil Burk & Mike Haas, Delta Research, 8/15/88
  19. \ Some modifications were needed to take advantage
  20. \ of some of JForth 2.0's new features, ie. Clone,
  21. \ Precompiled Assembler Module and Hashing.
  22. \ References to Status Register changed to use GetCC exec call.
  23. \
  24. \ MOD: PLB 7/10/89 Set FPWARN to TRUE instead of 1 for AND
  25. \ MOD: PLB 9/19/89 Increased accuracy of DEG/RAD,
  26. \          Changed FDUP to FOVER in F**
  27. \ MOD: PLB 4/24/90 Don't call SMUDGE0123
  28. \ MOD: PLB 7/31/90 FIX converted to high level.
  29. \ 00001 PLB 9/23/91 Check for FPEXP > 61 in F>TEXT F>ETEXT
  30. \ 00002 PLB 9/26/91 Add AUTO.TERM
  31. \ 00003 PLB 1/4/92 Added FLOAT.NUMBER? FASTFP.NUMBER? FNUMBER?
  32. \ 00004 PLB 2/25/92 Fixed AUTO.TERM which used to call AUTO.INIT
  33. \ 00005 PLB 4/28/92 Fixed FLOAT and >F for large negative numbers.
  34.  
  35. \ <<<<<<<<<<<<<<<
  36. \
  37. \ Arithmetic operators:
  38. \  F+  F-  F*  F/  FABS  FNEGATE  FMAX  FMIN  F2*  F2/
  39. \
  40. \ Transendental functions:
  41. \  FLOG   FLN    FSIN    FCOS    FTAN     FSINH   FCOSH   FTANH
  42. \  FALOG  FALN   FASIN   FACOS   FATAN    FSQRT   F**
  43. \  FCS    FATCS  DEG>RAD RAD>DEG DEG/RAD  PI      PI/2    2PI
  44. \
  45. \ Logical operators:
  46. \  F0=   F0<   F0>    F=    F<    F>
  47. \  F0<>  F0<=  F0>=   F<=   F>=   F<>
  48. \  FEQ   FLT   FGT    FNE   FLE   FGE   FVS   FVC
  49. \
  50. \ Stack operators:
  51. \  FDROP   FDUP    FOVER   FSWAP   FROT
  52. \  F>R     FR>     FR@     FRDROP
  53. \  FNOVER  NFOVER  FNSWAP  NFSWAP
  54. \  FFNROT  FNFROT  NFFROT  FNNROT  NFNROT  NNFROT
  55. \  FCELL   FCELL+  FCELL-  FCELLS  FCELL/  FCELLU/
  56. \
  57. \ Number handling operators:
  58. \  FLOAT  FIX (rounded)  INT (truncated)
  59. \  F!  F@  FCONSTANT  FVARIABLE  FARRAY
  60. \  FNUMBER  PACK  UNPACK  F#BYTES  F#PLACES
  61. \
  62. \ Display operators:
  63. \  F.   E.   ENG.   PLACES (sets FFLD described below)
  64. \  F.R  E.R  ENG.R  (display rounded and right justified in field)
  65. \  F>TEXT  F>ETEXT  F>ENGTEXT ( create f., e., and eng. strings )
  66. \
  67. \ Display operators & variables - not in FVG84:
  68. \  FLD         - total width of field for number displays
  69. \  FFLD        - width of fractional field for F. - places after decimal
  70. \  EFFLD       - width of fractional field for E. and ENG.
  71. \  F.EMAX      - maximum exponent for decimal form display for F.
  72. \  F.ENDPOINT  - flag indicating whether to use a point at end of F. display
  73. \  DP-CHARS    - symbols for decimal point and comma - allows Euro style
  74. \  E.PLUS      - flag for "E+01" rather than "E01" - aligns with "E-01"
  75. \  EXPSYMBOL   - symbol for "E" for E. and ENG. - allows upper or lower "E"
  76. \  COMMAS      - use commas (from Jforth) in F. and integer displays
  77. \  NO-COMMAS   - don't use commas in F. and integer displays
  78. \  FPWARN      - flag to display floating point warning messages
  79. \
  80. \ Number interpreters - fp only interpreted if base is 10 - not in FVG84:
  81. \  FLOAT.INTERPRET  - integers, decimal form and "E" form real numbers
  82. \  FASTFP.INTERPRET - integers and decimal form real numbers
  83. \  FIX.INTERPRET    - integers
  84. \  NTYPE            - number type variable  1 = int, 2 = fp, 0 = not number
  85. \
  86. \ Significant digits:
  87. \  The fp number interpreters and fp diplay routines provide
  88. \  7 significant digit conversions to and from floating point.
  89. \  For example, 1.2345678 F. will display 1.234568.
  90. \
  91.  
  92. only forth definitions
  93.  
  94. anew FP-DEFINITIONS
  95.  
  96. : FFP ;
  97.  
  98. : OPEN-MATHLIBS ( --- ) mathffp? mathtrans? ;
  99. : CLOSE-MATHLIBS ( --- ) -mathffp -mathtrans ;
  100. open-mathlibs  ( used by FLOAT at compilation )
  101.  
  102. decimal
  103.  
  104. \ Stack and memory operators  ==FVG84 required (except as noted)
  105. \ These operators are identical to their integer equivalent because
  106. \ ffp floating point and integer both require 4 bytes per number.
  107. \ The fp form of the operator should be used in application code so
  108. \ that the application will function properly when a floating point
  109. \ inplementation with a different number of bytes is substituted for ffp.
  110.  
  111. : F!    !    both ;
  112. : F@    @    both ;
  113. : FDROP drop both ;
  114. : FDUP  dup  both ;
  115. : FOVER over both ;
  116. : FSWAP swap both ;
  117. : FROT  rot  both ;
  118. : FCONSTANT  constant ;
  119. : FVARIABLE  variable ;
  120.  
  121. : F>R >r inline ; \ ==extensions to FVG84
  122. : FR> r> inline ;
  123. : FR@ r@ inline ;
  124. : FRDROP rdrop inline ;
  125. : FNOVER ( r n --- r n r ) over both ; \ mixed number type stack operators
  126. : NFOVER ( n r --- n r n ) over both ; \ ==extensions to FVG84
  127. : FNSWAP ( r n --- n r )   swap both ;
  128. : NFSWAP ( n r --- r n )   swap both ;
  129. : FFNROT ( r1 r2 n --- r2 n r1 ) rot both ;
  130. : FNFROT ( r1 n r2 --- n r2 r1 ) rot both ;
  131. : NFFROT ( n r1 r2 --- r1 r2 n ) rot both ;
  132. : FNNROT ( r n1 n2 --- n1 n2 r ) rot both ;
  133. : NFNROT ( n1 r n2 --- r n2 n1 ) rot both ;
  134. : NNFROT ( n1 n2 r --- n2 r n1 ) rot both ;
  135.  
  136. : FCELL+     ( n --- n ) cell+ both ; \ fp cell operators
  137. : FCELL-     ( n --- n ) cell- both ; \ ==extensions to FVG84
  138. : FCELLS     ( n --- n ) cells both ;
  139. : FCELL/     ( n --- n ) cell/ both ;
  140. code FCELLU/ ( n --- n ) 2 #  tos dn  lsr   both   rts   end-code
  141.  
  142. : FARRAY \ fp array with size error checking   == extension to FVG84
  143.     create dup , 0 do -1 , loop
  144.     does>  [ also assembler
  145.         dsp a@  0dr dn  move
  146.         1dr dn  clr
  147.         org tos 0 an+r+b  0dr dn  cmp
  148.         1dr dn  byte   scc
  149.         2 #     0dr dn  asl
  150.         0dr dn  tos dn  add
  151.         4 #     tos dn  addq
  152.         tos dn  dsp a@  move
  153.         1dr dn  tos dn  move
  154.     previous ] if ."  farray size" 0 error then ;
  155.  
  156. 4        constant  FCELL       \ number of bytes required for ffp
  157. -129     fconstant FINFINITY   \ internal use
  158. -1       fconstant F-INFINITY  \ internal use
  159. $ 20000  constant  FPOV        \ internal use
  160.     variable  FPWARN      \ if true, fp warning messages will display
  161. \                  1 fpwarn !  \ ==extension to FVG84
  162.         TRUE fpwarn !  \ ==extension to FVG84
  163.     variable  FPSTAT      \ status of last fp operation
  164.     \ bit flags (hex) 20000 = overflow
  165.     \ 40000 = zero    80000 = negative
  166.         \ other bits are undefined ==FVG84 optional
  167.  
  168. code FPCALL.1 ( r offset library -- r' ) \ 1 arg
  169.     org tos 0 an+r+b 0ar an move
  170.     dsp a@+ 0dr dn  move
  171.     6 #     0dr dn word muls
  172.     0dr dn  0ar an  suba
  173.     dsp a@+ 0dr dn  move
  174.     dsp an   7ar -a@  move        ( save a6 )
  175.     0ar 0 an+w      jsr
  176. \
  177.     0dr dn   0ar an   move        ( d0 to A0 )
  178.     4 abs.l  6ar an  move         ( get ExecBase )
  179.     6ar $ -210  an+w jsr          ( puts CC in d0 )
  180.     7ar a@+  dsp an  move         ( restore a6 )
  181.     0dr dn   7dr dn  word move    ( move d0 to TOS )
  182. \
  183. \      tos dn  move-from-sr ( status to TOS )
  184. \
  185.     ] fpstat w! [   ( use call for CLONE to resolve )
  186.     7dr dn   dsp -a@ move
  187.     0ar an   7dr dn  move
  188.     rts
  189. end-code
  190.  
  191. code FPCALL.2 ( r1 r2 offset library -- r' ) \ 2 arg call, reverse args
  192.     org tos 0 an+r+b 0ar an move
  193.     dsp a@+ 0dr dn  move
  194.     6 #     0dr dn word muls
  195.     0dr dn  0ar an  suba
  196.     dsp a@+ 1dr dn  move
  197.     dsp a@+ 0dr dn  move
  198.     6ar an   7ar -a@  move        ( save a6 )
  199.     0ar 0 an+w      jsr
  200. \
  201.     0dr dn   0ar an   move        ( d0 to A0 )
  202.     4 abs.l  6ar an  move         ( get ExecBase )
  203.     6ar $ -210  an+w jsr          ( puts CC in d0 )
  204.     7ar a@+  6ar an  move         ( restore a6 )
  205.     0dr dn   7dr dn  word move    ( move d0 to TOS )
  206. \
  207. \      tos dn  move-from-sr ( status to TOS )
  208. \      0dr dn  dsp -a@ move
  209. \
  210.     ] fpstat w! [
  211.     7dr dn   dsp -a@ move
  212.     0ar an   7dr dn  move
  213.     rts
  214. end-code
  215.  
  216. \ Macros must be compiled as INLINE code to work with
  217. \ new precompiled assembler module.
  218. code (FPC) \ floating point compare
  219.     dsp a@+  0dr dn  move
  220.     8   #    0dr dn  ror    3 bcc
  221.     31  #    0dr dn  bclr   0dr dn  neg
  222. 3 br: 8   #    tos dn  ror    4 bcc
  223.     31  #    tos dn  bclr   tos dn  neg
  224. 4 br: tos dn   0dr dn  cmp
  225. inline rts
  226. end-code
  227.  
  228. : FPC compile (FPC) ;
  229. : FPCEND ( -- compile b->s )
  230.     compile b->s
  231. ;
  232.  
  233. code (@>CCR) ( cc -- cc , copy codes to ccr )
  234.     org 7dr 0  an+r+b   move-to-ccr
  235.     inline rts
  236. end-code
  237.  
  238. \ These macros must compile BSR references to FPSTAT
  239. \ for proper cloning.
  240. : FPSTAT->CCR \ macro: move fp status to cond code reg
  241.     compile fpstat
  242.     compile (@>ccr)
  243. ;
  244.  
  245. code TEST.NZ  ( N -- N ccr )
  246.     tos dn  dsp -a@ move
  247.     tos dn  tst   9 beq
  248.     tos dn  byte tst
  249. 9 br: \ 7dr dn  move-from-sr
  250.     4 abs.l  0ar an  move
  251.     0ar $ -210 an+w jsr
  252.     0 # tos dn moveq
  253.     0dr dn tos dn word move
  254. both  \  inline
  255. rts
  256. end-code
  257.  
  258. : SET-FPSTAT  \ macro: test tos, set n & z in fpstat
  259.     compile test.nz
  260.     compile fpstat
  261.     compile w!
  262. ;
  263.  
  264. \ Fp logical operators that test the number on the top of the stack.
  265. \ The number is replaced on the stack with the test result flag.
  266. \ They do not set the condition codes in fpstat.
  267. \ ==FVG84 required (except as noted)
  268.  
  269. code F0=  ( r --- f )   tos dn  tst
  270.     tos dn  byte    seq   fpcend
  271.     both    rts     end-code
  272.  
  273. code F0<  ( r --- f )   7   #   tos dn  btst
  274.     tos dn  byte    sne   fpcend
  275.     both    rts     end-code
  276.  
  277. code F0>  ( r --- f )   1 #     tos dn  byte  rol
  278.     tos dn  byte    shi   fpcend
  279.     both    rts     end-code
  280.  
  281. code F0<> ( r --- f )   tos dn  tst                  \ ==extension to FVG84
  282.     tos dn  byte    sne   fpcend
  283.     both    rts     end-code
  284.  
  285. code F0<= ( r --- f )   1 #     tos dn  byte  rol    \ ==extension to FVG84
  286.     tos dn  byte    sls   fpcend
  287.     both    rts     end-code
  288.  
  289. code F0>= ( r --- f )   tos dn  byte    tst          \ ==extension to FVG84
  290.     tos dn  byte    sge   fpcend
  291.     both    rts     end-code
  292.  
  293. \ Fp logical operators that test the fpstat condition code of the last
  294. \ fp operation.  This allows very fast tests.  The resulting test flag
  295. \ is placed on the stack.  They do not set the condition codes in fpstat.
  296. \ Fvs and fvc test the overflow bit for being set or clear.
  297. \ ==extensions to FVG84
  298.  
  299. code FEQ ( --- f ) fpstat->ccr  tos dn byte seq  fpcend  both rts end-code
  300. code FLT ( --- f ) fpstat->ccr  tos dn byte slt  fpcend  both rts end-code
  301. code FGT ( --- f ) fpstat->ccr  tos dn byte sgt  fpcend  both rts end-code
  302. code FNE ( --- f ) fpstat->ccr  tos dn byte sne  fpcend  both rts end-code
  303. code FLE ( --- f ) fpstat->ccr  tos dn byte sle  fpcend  both rts end-code
  304. code FGE ( --- f ) fpstat->ccr  tos dn byte sge  fpcend  both rts end-code
  305. code FVS ( --- f ) fpstat->ccr  tos dn byte svs  fpcend  both rts end-code
  306. code FVC ( --- f ) fpstat->ccr  tos dn byte svc  fpcend  both rts end-code
  307.  
  308. \ Fp logical operators that compare two fp numbers on the stack.
  309. \ The two numbers are removed from the stack and replaced with
  310. \ the resulting test flag.  They do not set the condition codes
  311. \ in fpstat.   ==FVG84 required (except as noted)
  312.  
  313. code F=  ( r1 r2 --- f ) fpc  tos dn byte seq  fpcend  both  rts  end-code
  314. code F<  ( r1 r2 --- f ) fpc  tos dn byte slt  fpcend  both  rts  end-code
  315. code F>  ( r1 r2 --- f ) fpc  tos dn byte sgt  fpcend  both  rts  end-code
  316.     \ following are ==FVG84 extensions
  317. code F<> ( r1 r2 --- f ) fpc  tos dn byte sne  fpcend  both  rts  end-code
  318. code F<= ( r1 r2 --- f ) fpc  tos dn byte sle  fpcend  both  rts  end-code
  319. code F>= ( r1 r2 --- f ) fpc  tos dn byte sge  fpcend  both  rts  end-code
  320.  
  321.  
  322. \ Fp arithmetic operators   ==FVG84 required (except as noted)
  323. \ Fpstat condition codes are set by arithmetic operators
  324.  
  325. : F+    ( r1 r2 --- r )  11 mathffp_lib fpcall.2  ; \ spadd
  326. : F-    ( r1 r2 --- r )  12 mathffp_lib fpcall.2  ; \ spsub
  327. : F*    ( r1 r2 --- r )  13 mathffp_lib fpcall.2  ; \ spmul
  328. : F/    ( r1 r2 --- r )                              \ spdiv
  329.     fdup if     14 mathffp_lib fpcall.2
  330.     else fdrop fpwarn @ if ." ...warning " then
  331.         fdup f0> if fdrop finfinity fpov fpwarn @ if ." fp"  then
  332.         else f0< if f-infinity 655360    fpwarn @ if ." -fp" then
  333.         else 0. 393216                fpwarn @ if ." 0."  then
  334.             then then  fpstat !  fpwarn @ if ."  div by 0. " then
  335.         then ;
  336.  
  337. code CC2D0   ( get the cc, put in d0, wrecks a0 also )
  338.     4 abs.w  0ar an  move
  339.     0ar $ -210 an+w jsr
  340. inline end-code
  341.  
  342. \ Change to D1 to avoid conflict with GetCC
  343. code F2*   ( r --- r )
  344.     tos dn  1dr dn  byte  move   \ ==extension to FVG84
  345.     1   #   tos dn  addq  set-fpstat
  346.     tos dn  1dr dn  eor   1dr dn  byte  tst  1 bge
  347.     1   #   tos dn  subq  tos dn  byte  tst
  348. \
  349. \     2 # byte ori-ccr   org 2dr 0 an+r+b  move-from-sr
  350. \
  351.     ] cc2d0 [
  352.     2 #  0dr dn  word or
  353.     ] fpstat [
  354.     0dr dn   org tos 0 an+r+b  word move
  355.     dsp a@+  tos dn   move
  356. 1 br: rts     end-code
  357.  
  358. code F2/   ( r --- r )
  359.     tos dn  1dr dn  byte  move   \ ==extension to FVG84
  360.     1   #   tos dn  subq  set-fpstat
  361.     tos dn  1dr dn  eor   1dr dn  byte  tst  1 bge
  362. \
  363. \     org 2dr 0 an+r+b  move-from-sr
  364. \
  365.     ] cc2d0 [
  366.     ] fpstat [
  367.     0dr dn   org tos 0 an+r+b  word move
  368.     4 #  dsp an  addq
  369.     tos dn  clr
  370. 1 br: rts     end-code
  371.  
  372. code FABS  ( r --- r )  7   #   tos dn  bclr  set-fpstat        \ abs value
  373.     both    rts     end-code
  374.  
  375. code FNEGATE ( r --- r )  tos dn  tst   1 beq   7 #  tos dn  bchg \ chg sign
  376. 1 br: set-fpstat    both    rts  end-code
  377.  
  378. code FMAX  ( r1 r2 --- r ) tos dn  2dr dn  move    fpc    1 blt  \ max value
  379.     dsp -a@ tst     dsp a@+ tos dn move   2 bra
  380. 1 br: 2dr dn  tos dn  move
  381. 2 br: set-fpstat      both     rts   end-code
  382.  
  383. code FMIN  ( r1 r2 --- r ) tos dn  2dr dn  move    fpc    1 bgt  \ min value
  384.     dsp -a@ tst     dsp a@+ tos dn move   2 bra
  385. 1 br: 2dr dn  tos dn  move
  386. 2 br: set-fpstat      both     rts   end-code
  387.  
  388. \ Fp conversion routines  ==FVG84 required (except as noted)
  389. \ Fpstat condition codes are set by conversion routines
  390.  
  391. \ Call FPSTAT
  392. : (FLOAT)   ( n --- r )                                      \ spflt
  393.     6 mathffp_lib fpcall.1
  394. ;
  395.  
  396. code $200000/mod  ( d --- n d ) \ 21 bit div mod
  397.     tos dn  0dr dn  move    3dr dn  byte    slt
  398.     3dr dn  word    ext     3dr dn          ext
  399.     dsp a@  1dr dn  move    1dr dn  2dr dn  move
  400.     $ ffe00000 # 3dr dn and $ 1fffff #  2dr dn and
  401.     3dr dn  2dr dn  or      2dr dn  dsp a@  move
  402.     21 #    4dr dn  move    4dr dn  tos dn  asr
  403.     4dr dn  1dr dn  lsr     11 #    4dr dn  move
  404.     4dr dn  0dr dn  lsl     1dr dn  0dr dn  or
  405.     0dr dn  dsp -a@ move    rts
  406. end-code
  407.  
  408. \ Patch suggested by Rob Andre 00005
  409. : FLOAT  ( n --- r ) \ assumes that spflt can only handle 21 bits accurately
  410.     dup abs $ 200000 >
  411.     IF
  412.         s->d  \ it actually seems to handle 24 bits
  413.         dup 0< >r dabs
  414.         $200000/mod drop (float) 21 + nfswap (float) f+ \ we can do 31 + sgn
  415.         r>
  416.         IF fnegate
  417.         THEN
  418.     ELSE (float)
  419.     THEN
  420. ;
  421.  
  422. \ Call FPSTAT
  423.  
  424. 1         float     fconstant  F1
  425. 100000000 float     fconstant  F100000000
  426. f1 f100000000 f/    fconstant  F.00000001
  427.  
  428. : INT     ( r --- n )                  \ truncate and convert to integer
  429.     5 mathffp_lib fpcall.1
  430.     FVC NOT
  431.     IF  drop 0
  432.         fpwarn @ if ." ...warning fp too large for int" then
  433.     THEN
  434. ;
  435.  
  436. : FIX ( r -- i , round then integerize )
  437.     fdup f0>
  438.     IF [ f1 f2/ ] literal
  439.     ELSE [ f1 f2/ fnegate ] literal
  440.     THEN
  441.     f+ INT
  442. ;
  443.  
  444. \ Fp transendental functions.  Fpstat condition codes are set by these
  445. \  functions.   ==FVG84 required or optional (except as noted).
  446. \ If transendental functions are wanted (or not wanted)
  447. \  place true (or false) prior to the .if on the next line
  448. \ The transendental functions use about 1500 bytes.
  449. true .if
  450.  
  451. 3373259586 fconstant PI
  452. 3373259585 fconstant PI/2       \ ==extension to FVG84
  453. 3373259587 fconstant 2PI        \ ==extension to FVG84
  454. \ 3845055046 fconstant DEG/RAD    \ ==extension to FVG84
  455. 3845054790 fconstant DEG/RAD    \ ==extension to FVG84
  456.  
  457. : F**   ( r1 r1 --- r )                                      \ sppow
  458. \     fdup f0>= if 15 mathtrans_lib fpcall.2
  459.     FOVER f0>=
  460.     IF 15 mathtrans_lib fpcall.2
  461.     ELSE fdrop fdrop 0 fpov fpstat !
  462.         fpwarn @ if ." ...warning power of neg number" then
  463.     THEN
  464. ;
  465.  
  466. : FSQRT   ( r --- r )                                     \ spsqrt
  467.     fdup f0>= if  16 mathtrans_lib fpcall.1
  468.     else fdrop 0 fpov fpstat !
  469.         fpwarn @ if ." ...warning sqrt of neg number" then
  470.     then ;
  471.  
  472. : FLN     ( r --- r )                                      \ splog
  473.     fdup f0> if  14 mathtrans_lib fpcall.1
  474.     else fdrop f-infinity fpov fpstat !
  475.         fpwarn @ if ." ...warning ln of 0 or neg number" then
  476.     then ;
  477.  
  478. : FLOG    ( r --- r )                                      \ splog10
  479.     fdup f0> if  21 mathtrans_lib fpcall.1
  480.     else  fdrop  f-infinity  fpov fpstat !
  481.         fpwarn @ if ." ...warning log of 0 or neg number" then
  482.     then ;
  483.  
  484.  
  485. : FALOG ( r --- r )  2684354628 swap f** ;            \ alog10
  486. : FALN  ( r --- r )  13 mathtrans_lib fpcall.1 ;      \ spexp
  487.  
  488. : FSIN  ( r.rad --- r )  6 mathtrans_lib fpcall.1  ;  \ spsin
  489. : FCOS  ( r.rad --- r )  7 mathtrans_lib fpcall.1  ;  \ spcos
  490. : FTAN  ( r.rad --- r )  8 mathtrans_lib fpcall.1  ;  \ sptan
  491. : FASIN ( r --- r.rad ) 19 mathtrans_lib fpcall.1  ;  \ spasin
  492. : FACOS ( r --- r.rad ) 20 mathtrans_lib fpcall.1  ;  \ spacos
  493. : FATAN ( r --- r.rad )  5 mathtrans_lib fpcall.1  ;  \ spatan
  494.  
  495. : FSINH ( r.rad --- r ) 10 mathtrans_lib fpcall.1  ;  \ spsinh
  496. : FCOSH ( r.rad --- r ) 11 mathtrans_lib fpcall.1  ;  \ spcosh
  497. : FTANH ( r.rad --- r ) 12 mathtrans_lib fpcall.1  ;  \ sptanh
  498.  
  499. \ Call variables.
  500. code FCS ( r.rad --- r.sin r.cos )            \ cosine & sine  - spsincos
  501.     tos dn  0dr dn  move    \ ==extension to FVG84
  502.     ] mathtrans_lib [
  503.     dsp an  1dr dn  move
  504.     org tos 0 an+r+b 0ar an move
  505.     0ar -54 an+w    jsr     dsp a@    tos dn   move
  506.     0dr dn  dsp a@  move    set-fpstat \ sets fpstat for cosine
  507.     rts     end-code
  508.  
  509. : FATCS  ( r.sin r.cos --- r.rad ) \ four quadrant atan - fortran's atan2
  510.     fdup f0< if -1 else 0 then >r \ ==extension to FVG84
  511.     fdup f0= if fdrop
  512.         f0> if pi/2 else pi/2 fnegate then
  513.     else f/ fatan
  514.     then
  515.     r> if pi fover f0> if f- else f+ then then ;
  516.  
  517. : DEG>RAD deg/rad f/ ; \  convert degrees to radians   ==extension to FVG84
  518. : RAD>DEG deg/rad f* ; \  convert radians to degrees   ==extension to FVG84
  519.  
  520. .then   \ end of transendental functions
  521.  
  522.  
  523.  
  524. \ Fp ascii conversion and display routines.  Fpstat is not set by the ascii
  525. \ conversion and display routines.  Fpstat from a prior fp operation is not
  526. \ preserved through these routines.
  527. \ ==FVG84 required, optional, or extension is indicated with each routine.
  528.  
  529.  
  530. variable FFLD       \ fractional field - digits to display after decimal
  531. -1 ffld !           \  when displayed with f.  min=0 max=7 (-1=variable)
  532.     \ ==extension to FVG84
  533.  
  534. variable F.EXMAX    \ Maximum exponent for which to use for decimal form
  535.     9 f.exmax !        \  when displayed with f. (larger exponents use e-form
  536.         \ ==extension to FVG84
  537.  
  538. variable F.ENDPOINT \ Flag indicating to put a point at the end
  539. -1 f.endpoint !     \  of a f. display when appropriate.
  540.     \ ==extension to FVG84
  541.  
  542. variable EFFLD      \ fractional field in mantissa when displayed with e.
  543. 6 effld !           \  min = 0  max = 6 (no variable width feature)
  544.     \ ==extension to FVG84
  545.  
  546. variable E.PLUS     \ true indicates to place "+" after "e" (e.g. "e+06")
  547. 1 e.plus !          \ ==extension to FVG84
  548.  
  549. variable EXPSYMBOL  \ contains ascii symbol for exponent in e form
  550. ascii e expsymbol ! \ ==extension to FVG84
  551.  
  552. 4 constant F#BYTES  \ number of bytes in a floating point number
  553.     \ ==FVG84 optional
  554.  
  555. 7 constant F#PLACES \ maximum number of significant digits in fp number
  556.     \ ==FVG84 optional
  557.  
  558. variable DP-CHARS      \ double precision characters  ==FVG84 extension
  559. ascii . dp-chars w!    \ . is normal decimal point
  560. ascii , dp-chars 2+ w! \ , is normal digits separator
  561.  
  562.  
  563.  
  564.  
  565. variable  SIGDIG    variable  UNPP2         \ variables for internal use
  566. fvariable UNPREAL   fvariable UNPMULT   variable UNPEX
  567.  
  568.  
  569. : FLOATEXP  ( n --- n r ) \  convert int exp to fp power of 10
  570.     dup 0> if               \   factored to real and int power of 2
  571.         dup 21 < if          \  for internal use
  572.             dup 8 > if f100000000 nfswap 8 - else f1 nfswap then
  573.             0 1 rot ?dup if 0 do 5 * swap 1+ swap loop then
  574.             float fnfrot f*
  575.         else drop 0 finfinity
  576.             fpwarn @ if ." ... warning fp infinity " then
  577.         then
  578.     else
  579.         dup -21 > if
  580.             dup -8 < if f.00000001 nfswap 8 + else f1 nfswap then
  581.             0 1 rot ?dup if abs 0 do 5 * swap 1- swap loop then
  582.             float fnfrot fswap f/
  583.         else drop 0 0 then
  584.     then ;
  585.  
  586.  
  587. : FPEXP 127 and 64 - ;     \ for internal use
  588.  
  589. \ fix suggested by Rob Andre 00005
  590. : >F ( d --- r ) \ converts double integer with decimal point to float
  591. \  uses position of decimal point indicated by dpl
  592. \  to position decimal point in floating point number
  593. \ ==extension to FVG84
  594.     ddup or
  595.     if
  596.         dup 0< >r
  597.         dabs
  598.         $200000/mod $200000/mod drop (float) 42 +
  599.         nfswap (float) 21 + f+ nfswap (float) f+
  600.         dpl @ dup 0>
  601.         IF floatexp + f/
  602.         ELSE drop
  603.         THEN
  604.         r>
  605.         IF fnegate
  606.         THEN
  607.     ELSE
  608.         drop
  609.     THEN
  610.     -1 dpl !
  611. ;
  612.  
  613. : NUNPACK ( r --- n1 n2 ) \ float to n1: mantissa 1.2345678  n2: exponent
  614. \  for internal use
  615.     unpreal f!  f1 unpmult f!   0 unpex !   0 unpp2 !
  616.     unpreal f@ f0<> if
  617.         begin unpreal f@ unpmult f@ f/ fpexp  unpp2 @ -
  618.             0> while unpex @ 1+ dup unpex ! floatexp unpmult f! unpp2 ! repeat
  619.         begin unpreal f@ unpmult f@ f/ fpexp unpp2 @ - 1-
  620.             0< while unpex @ 1- dup unpex ! floatexp unpmult f! unpp2 ! repeat
  621.         unpreal f@ unpmult f@ f/ f100000000 f1 unpp2 @ - f* f* fix
  622.         fpwarn @ if
  623.             unpex @ 18 = if dup abs 922337100 > else 0 then
  624.             if ." ...warning fp infinity " then
  625.         then
  626.     else 0 then unpex @ ;
  627.  
  628. : UNPKROUND ( n1 n2 n3 --- n1 n2 ) \ round unpacked num n1,n2 to n3 sig dig
  629.     \  n3 must be a number between 1 and 7
  630.         sigdig ! swap dup abs        \ for internal use
  631.         5 8 sigdig @ - 0 do 10 * loop dup sigdig ! +
  632.         sigdig @ dup + swap over / *
  633.         dup 999999999 > if 10 / rot 1+ rot rot then
  634.         swap 0< if -1 * then
  635.         swap ;
  636.  
  637. : NPACK ( n1 n2 --- r )      \ n1: signed-integer-mantissa
  638.     7 unpkround floatexp      \     with 8 implied decimal places
  639.     rot 0 >f                  \ n2: signed-integer-exponent
  640.     rot + f100000000 f/ f*    \ r:  7 sig dig num in ffp form
  641.     fpwarn @ if dup 128 or -1 = if ." ... warning fp infinity " then
  642.     then ;                    \ for internal use
  643.  
  644. : PACK  ( d n --- r )        \ d: signed double-integer mantissa with 16
  645.     >r 100000000 m/ swap drop \    implied decimal places.
  646.     r> npack ;                \ n: signed integer exponent  ==FVG84 optional
  647.  
  648. : UNPACK ( r --- d n )       \ d: signed double-integer mantissa with
  649.     nunpack >r 100000000 m*   \    16 implied decimal places.
  650.     r> ;                      \ n: signed integer exponent  ==FVG84 optional
  651.  
  652.  
  653. variable  E.CNT  variable E.EXCNT              \ variables for internal use
  654. variable F.MT    variable F.EX    variable F.MULT    variable F.CFLG
  655. variable F.DIV   variable F.CH    variable F.FFLD
  656.  
  657.  
  658. : (F>ETEXT) ( n1 n2 --- addr count ) \ internal use
  659.     effld @ 1+ unpkround
  660.     5 e.cnt ! (commas) @ >r no-commas
  661.     <# dup abs s->d # # ddrop 0< if ascii - hold e.cnt @ 1+ e.cnt !
  662.         else e.plus @ if ascii + hold e.cnt @ 1+ e.cnt ! then
  663.         then expsymbol @ hold
  664.         dup abs 10 7 effld @ - 0 do 10 * loop / s->d
  665.         effld @ ?dup if 0 do # loop then
  666.         effld @ e.cnt @ + e.cnt !
  667.         dp-chars w@ hold # rot
  668.         0< if ascii - hold e.cnt @ 1+ e.cnt ! then
  669.         fld @ dup 0< if drop
  670.         else e.cnt @ - 1- dup 0> if 0 do 32 hold loop else drop then
  671.         then
  672.     #> r> (commas) ! ;
  673.  
  674. : F>ETEXT ( r --- addr count )
  675. \ Converts fp to e-form text
  676. \ same as e. (below) but no printing
  677.     fdup fpexp  61 >
  678.     IF
  679.         fdrop " Infinity" count
  680.     ELSE
  681.         nunpack (f>etext)         \ ==extension to FVG84
  682.     THEN
  683. ;
  684.  
  685. : E. ( r1 --- ) \ display floating-point in exponential form
  686.     f>etext       \  uses the variable "fld" to indicate width of
  687.     type space ;  \   the display field (-1=variable width)
  688.     \   if field is not wide enough for number,
  689.     \    the number will be displayed overflowing the field
  690.     \  uses the variable "effld" to indicate width of the
  691.     \   mantissa fractional field (places after decimal point)
  692.     \   (min = 0   max = 6)
  693.     \  uses the variable "e.plus". if true a + is placed
  694.     \   after the "e" so that e+06 and e-06 will line up.
  695.     \  ==FVG84 required  with extended features
  696.  
  697. : E.R ( r n1 n2 --- )       \ e form display of floating point number
  698.     fld @ >r fld !        \ with n1 places to right of the decimal
  699.     effld @ >r            \ right justified in a field n2 characters wide.
  700.     dup 7 < over -1 > and \ ==FVG84 optional
  701.     not if drop r@ then effld !
  702.     e. r> effld ! r> fld ! ;
  703.  
  704.  
  705. : (F>ENGTEXT) ( r --- addr count )
  706. \ Converts fp to eng-form text
  707. \ same as eng. (below) but no printing
  708.     (commas) @ >r no-commas       \ ==extension to FVG84
  709.     nunpack effld @ 1+ unpkround
  710.     dup 3 mod dup 0< if 3 + then dup  e.excnt !  -
  711.     5 e.cnt !
  712.     <# dup abs s->d # # ddrop 0< if ascii - hold e.cnt @ 1+ e.cnt !
  713.         else e.plus @ if ascii + hold e.cnt @ 1+ e.cnt ! then
  714.         then expsymbol @ hold
  715.         dup abs 10 7 effld @ - 0 do 10 * loop / s->d
  716.         effld @ e.excnt @ - ?dup if 0 do # loop then
  717.         effld @ e.cnt @ + e.cnt !
  718.         dp-chars w@ hold
  719.         e.excnt @ 1+ 0 do # loop rot
  720.         0< if ascii - hold e.cnt @ 1+ e.cnt ! then
  721.         fld @ dup 0< if drop
  722.         else e.cnt @ - 1- dup 0> if 0 do 32 hold loop else drop then
  723.         then
  724.     #> r> (commas) !
  725. ;
  726.  
  727. : F>ENGTEXT ( r --- addr count )
  728.     fdup fpexp  61 >
  729.     IF
  730.         fdrop " Infinity" count
  731.     ELSE
  732.         (f>engtext)
  733.     THEN
  734. ;
  735.  
  736. : ENG. ( r1 --- ) \ display floating-point in engineering exponential form
  737.     f>engtext       \  with exponents ...,-06,-03,00,03,06,...
  738.     type space ;    \  uses the variable "fld" to indicate width of
  739. \   the display field (-1=variable width)
  740. \   if field is not wide enough for number,
  741. \    the number will be displayed overflowing the field
  742. \  uses the variable "effld" to indicate width of the
  743. \   mantissa display field. (effld + 1 = num sig dig)
  744. \   (effld min = 0,  effld max = 6)
  745. \  uses the variable "e.plus". if true a + is placed
  746. \   after the "e" so that e+06 and e-06 will line up.
  747. \ ==extension to FVG84
  748.  
  749.  
  750. : ENG.R ( r n1 n2 --- )  \ engineering form display of r with
  751.     fld @ >r fld !      \ with n1 + 1 significant digits
  752.     effld @ >r          \ right justified in a field n2 characters wide
  753.     dup 7 < over -1 > and \ ==extension of FVG84
  754.     not if drop r@ then effld !
  755.     eng. r> effld ! r> fld ! ;
  756.  
  757.  
  758. : -COMMA?                         \ for internal use
  759.     (commas) @ if
  760.         f.cflg @ 1+ 3 mod dup f.cflg !
  761.         0= if dp-chars 2+ w@ 1 f.ch +! then
  762.     then ;
  763.  
  764. : +COMMA?                         \ for internal use
  765.     (commas) @ if
  766.         f.cflg @ 1- 3 mod dup f.cflg !
  767.         0= if dp-chars 2+ w@ 1 f.ch +! then
  768.     then ;
  769.  
  770.  
  771. : NEXTDIGIT  ( --- c1 )      \ put next dig on stack
  772.     f.div @ 0> if           \ for internal use
  773.         f.mt @ f.div @ /mod swap f.mt !
  774.         f.div @ 10 / f.div !
  775.     else 0
  776.     then  ascii 0 +  1 f.ch +! ;
  777.  
  778. : F.-EX                      \ used by f. when exp is <0
  779. \ for internal use
  780.     f.ffld @ 0= if ascii 0  dp-chars w@ 2 f.ch +!
  781.     else dp-chars w@ 1 f.ch +!  0 f.cflg !
  782.         f.ffld @ 0 do  1 f.ex +!
  783.             f.ex @ 0< if ascii 0  1 f.ch +!
  784.             else nextdigit then
  785.             f.mt @ 0= ffld @ 0< and if leave
  786.             else f.ffld @ i 1+ > if -comma? then
  787.             then
  788.         loop
  789.     then ;
  790.  
  791. : F.+EX                      \ used by f. when exp is 0>=
  792. \ for internal use
  793.     f.ex @ 1+ 0 do  nextdigit  +comma?  loop
  794.     (commas) @ if drop -1 f.ch +! then 0 f.cflg !
  795.     dp-chars w@ 1 f.ch +!
  796.     ffld @ 0< if
  797.         f.mt @ 0= not if
  798.             f.ffld @ 0 do nextdigit
  799.                 f.mt @ 0= if leave
  800.                 else f.ffld @ i 1+ > if -comma? then
  801.                 then
  802.             loop
  803.         then
  804.     else
  805.         ffld @ 0 do nextdigit loop
  806.     then ;
  807.  
  808. : SET-F.FFLD ( --- )       \ Sets f.ffld - used by f>text
  809.     ffld @ 0< if 7       \               for internal use only
  810.     else
  811.         ffld @ 1+
  812.         f.ex @ + dup 7 > if drop 7 then
  813.     then f.ffld ! ;
  814.  
  815. : (F>TEXT) ( r --- addr count ) \ Converts fp to text
  816. \ same as f. (below) but no printing
  817.     nunpack                    \ ==extension to FVG84
  818.     f.ex !  f.mt !
  819.     set-f.ffld
  820.     f.mt @ f.ex @ f.ffld @ unpkround f.ex ! f.mt !
  821.     f.ex @ 0< if
  822.         ffld @ dup 0< if drop 7 then f.ex @ +
  823.         0< if 0 f.ex ! 0 f.mt ! set-f.ffld then
  824.     then
  825.     f.ex @ ffld @ 0< if abs then
  826.     f.exmax @ > if
  827.         f.mt @ f.ex @ (f>etext)
  828.     else
  829.         f.ex @ 1+ 3 mod dup 0< if 3 + then f.cflg !
  830.         f.ffld @ f.ex @ - 1- dup 0< if drop 0 then
  831.         dup 7 > if drop 7 then f.ffld !
  832.         0 f.ch !  100000000 f.div !
  833.         f.mt @ f.mult !
  834.         f.mt @ abs f.mt !
  835.         f.ex @ 0< if f.-ex else f.+ex then
  836.         f.endpoint @ 0= over dp-chars w@ = and if drop -1 f.ch +! then
  837.         <# f.ch @ 0 do hold loop
  838.             f.mult @ 0< if ascii - hold 1 f.ch +! then
  839.             fld @ dup 0< if drop
  840.             else
  841.                 f.ch @ - 1- dup 0> if 0 do 32 hold loop else drop then
  842.             then
  843.         0 0 #>
  844.     then
  845. ;
  846.  
  847. : F>TEXT ( r --- addr count )
  848.     fdup fpexp  61 >
  849.     IF
  850.         fdrop " Infinity" count
  851.     ELSE
  852.         (f>text)
  853.     THEN
  854. ;
  855.  
  856. : F. ( r1 --- ) \ display floating-point in decimal form
  857.     f>text type  \  uses the variable "fld" to indicate width of
  858.     space ;      \   the display field (-1=variable width)
  859. \   if field is not wide enough for number,
  860. \    the number will be displayed overflowing the field
  861. \  uses the variable "ffld" to indicate width
  862. \   of the fractional field (places after decimal point)
  863. \   (-1=variable width) (max 6 if r1 >= 1., 7 if < 1.)
  864. \ ==FVG84 required  with extended features
  865.  
  866. : F.R ( r n1 n2 --- )  \ display fp with n1 fractional places
  867.     fld @ >r fld !   \ right justified in a field n2 characters wide
  868.     ffld @ >r ffld ! \ ==FVG84 optional
  869.     f. r> ffld ! r> fld ! ;
  870.  
  871.  
  872. : PLACES ( n --- )    \ sets default number of fractional digits
  873.     ffld ! ;         \  when fp number is displayed by f.
  874.         \  ==FVG84 required
  875.  
  876.  
  877. variable E.LOCATION          variable MANT.LENGTH   \ all for internal use
  878. create   E.STRING 30 allot   variable EXP.LENGTH    variable NTYPE
  879. ascii E 256 * ascii e + constant ASCII-Ee
  880.  
  881. code cmatch? ( string cnt b --- pointer-to-matching-char-in-string | false )
  882. \ the "byte" may be 2 bytes - e.g. ascii E 256 * ascii e +
  883.     dsp a@+  0dr dn  move       dsp a@+  1dr dn  move
  884.     org an   0ar an  move       1dr dn   0ar an  adda
  885.     0dr dn   1dr dn  add        0dr dn   neg
  886.     tos dn   2dr dn  move       8 #      2dr dn  lsr
  887. 1 br:  0ar a@   tos dn  byte  cmp  2 beq
  888.     0ar a@+  2dr dn  byte  cmp  2 beq
  889.     1 #      0dr dn  addq       1 blt
  890.     0 #      tos dn  move       3 bra
  891. 2 br:  0dr dn   1dr dn  add        1dr dn   tos dn  move
  892. 3 br:  rts       end-code
  893.  
  894. \ --- BEGIN 00003 ----------
  895. : FASTFP.NUMBER? ( addr --- r 0 true | n 0 true | false )
  896. \ Converts string at addr to number
  897. \  if it contains a decimal point,
  898. \  it will be converted to floating.
  899. \ Maximum input = 18 digits but only
  900. \  7 significant digits are retained.
  901.     0 ntype !
  902.     dup count swap c@ ascii - = +
  903.     20 <
  904.     IF number?
  905.     ELSE  drop false exit
  906.     THEN
  907.     IF base @ 10 = dpl @ 1+ 0> and
  908.         IF >f 0 -1 dpl ! 2
  909.         ELSE 1
  910.         THEN ntype !
  911.     ELSE false exit
  912.     THEN
  913.     true \ we made it!
  914. ;
  915.  
  916.  
  917. : FLOAT.NUMBER? ( addr --- r 0 true | n 0 true | false )
  918. \ Converts string at addr to number
  919. \  if it contains a decimal point, it will
  920. \  be converted to floating.  Accepts e-form
  921. \ Examples of acceptable numbers:
  922. \  123 1.234   12.34e5  12.34E5  1.234e+5
  923. \  2e5  e5  negatives in both mantissa
  924. \  and exponent, but not -e5 - it must be
  925. \  -1e5.  Max exp is +/- 18.
  926. \ Max mantissa input = 18 digits but
  927. \  only 7 significant digits are retained
  928. \  ==extension to FVG84
  929.     0 ntype !
  930.     dup count ascii-Ee cmatch?
  931.     IF
  932.         base @ 10 = not
  933.         IF fastfp.number?
  934.         ELSE  e.string over c@ 1+
  935.             dup 26 <
  936.             IF cmove
  937.             ELSE  2drop drop false exit \ main too long
  938.             THEN
  939.             e.string count ascii-Ee cmatch? e.location !
  940.             e.location @ e.string - 1-  mant.length !
  941.             e.string c@ mant.length @ - 1- exp.length !
  942.             mant.length @ e.string c!
  943.             exp.length @ e.location @ c!
  944.             e.string count swap c@ ascii - = + 19 >
  945.             IF  false exit
  946.             THEN
  947.             ( dp-chars 2+ w@ >r dp-chars w@ dp-chars 2+ w! )
  948.             e.string dup c@ 0=
  949.             IF drop  1 0 -1 dup dpl !
  950.             ELSE number?
  951.             THEN
  952.             IF
  953.                 >f e.location @ number?
  954.                 ( r> dp-chars 2+ w! )
  955.                 dpl @ -1 = and
  956.                 IF drop floatexp >r + r> f*
  957.                     finfinity fover f= fnover f-infinity f= or fpwarn @ and
  958.                     IF ." ... warning fp infinity "
  959.                     THEN
  960.                     0 -1 dpl ! 2 ntype !
  961.                 ELSE
  962.                     drop false exit \ bad exponent
  963.                 THEN
  964.             ELSE
  965.                 ( r> dp-chars 2+ w! )
  966.                 false exit  \ bad main number
  967.             THEN
  968.             true
  969.         THEN
  970.     ELSE
  971.         fastfp.number?
  972.     THEN
  973. ;
  974.  
  975.  
  976. : FASTFP.NUMBER ( addr --- r 0 | n 0 )
  977.     fastfp.number? 0=
  978.     IF
  979.         0 error
  980.     THEN
  981. ;
  982.  
  983. : FLOAT.NUMBER ( addr --- r 0 | n 0 )
  984.     float.number? 0=
  985.     IF
  986.         0 error
  987.     THEN
  988. ;
  989.  
  990. : FNUMBER? ( addr --- r true | false )  \ convert string to floating point
  991.     float.number? nip ntype @ 2 <
  992.     IF 2drop false
  993.     THEN
  994. ;
  995. : FNUMBER ( addr --- r )  \ convert string to floating point
  996.     \  ==FVG84 optional
  997.     fnumber? 0= if 0 error then
  998. ;
  999. \ --- END 00003 ----------
  1000.  
  1001. \ This smudging and unsmudging caused many problems in cloned
  1002. \ applications so we took it out!!
  1003. : SMUDGE0123 \ smudge the names of numbers so ntype won't be circumvented
  1004.     ' 0 ' 1 ' 2 ' 3 4 0 do >name dup c@ 32 or swap c! loop
  1005.     hash-damaged on ; \ internal use
  1006.  
  1007. : UNSMUDGE0123 \ unsmudge the names of numbers so they can be found
  1008.     ' 0 ' 1 ' 2 ' 3 4 0 do >name dup c@ 223 and swap c! loop
  1009.     hash-damaged on ; \ internal use
  1010.  
  1011. \ Initialization and control.
  1012. : FLOAT.INTERPRET ( --- )      \ integer, decimal form, or "E" form
  1013.     ' float.number is number  \ decimal point indicates floating point
  1014. \  smudge0123
  1015.     open-mathlibs ;    \ ==extension to FVG84
  1016.  
  1017. : FIX.INTERPRET ( --- )        \ put it back the old way
  1018.     ' (number) is number      \ ==extension to FVG84
  1019.     0 ntype !
  1020. \  unsmudge0123
  1021. ;
  1022.  
  1023. : FASTFP.INTERPRET ( --- )     \ integer or decimal form (no "E" form)
  1024.     ' fastfp.number is number \ decimal point indicates floating point
  1025. \  smudge0123
  1026.     open-mathlibs ;  \ ==extension to FVG84
  1027.  
  1028. : FPINIT float.interpret 0 ntype ! ;
  1029. : FPTERM fix.interpret close-mathlibs ;
  1030.  
  1031. : AUTO.INIT ( -- , start floating point if loaded)
  1032.     auto.init fpinit
  1033.     ." Floating Point Initialized!" cr
  1034. ;
  1035.  
  1036. : AUTO.TERM ( -- , term floating point if loaded 00002 )
  1037.     fpterm auto.term \ 00004
  1038. ;
  1039.  
  1040. \ Reset NUMBER vector if this code forgotten.
  1041. if.forgotten fpterm
  1042.  
  1043. close-mathlibs
  1044.  
  1045. cr ." Enter:   FPINIT  to start floating point" cr
  1046.  
  1047.